home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / cell.lisp < prev    next >
Encoding:
Text File  |  1992-02-24  |  11.4 KB  |  358 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: cell.lisp,v 1.56 92/02/24 00:43:42 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: cell.lisp,v 1.56 92/02/24 00:43:42 wlott Exp $
  15. ;;;
  16. ;;;    This file contains the VM definition of various primitive memory access
  17. ;;; VOPs for the MIPS.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. ;;; Converted by William Lott.
  22. ;;; 
  23.  
  24. (in-package "MIPS")
  25.  
  26.  
  27. ;;;; Data object definition macros.
  28.  
  29. (define-for-each-primitive-object (obj)
  30.   (collect ((forms))
  31.     (let ((lowtag (primitive-object-lowtag obj)))
  32.       (dolist (slot (primitive-object-slots obj))
  33.     (let* ((name (slot-name slot))
  34.            (offset (slot-offset slot))
  35.            (rest-p (slot-rest-p slot))
  36.            (slot-opts (slot-options slot))
  37.            (ref-trans (getf slot-opts :ref-trans))
  38.            (ref-vop (getf slot-opts :ref-vop ref-trans))
  39.            (set-trans (getf slot-opts :set-trans))
  40.            (setf-function-p (and (listp set-trans)
  41.                      (= (length set-trans) 2)
  42.                      (eq (car set-trans) 'setf)))
  43.            (setf-vop (getf slot-opts :setf-vop
  44.                    (when setf-function-p
  45.                  (intern (concatenate
  46.                       'simple-string
  47.                       "SET-"
  48.                       (string (cadr set-trans)))))))
  49.            (set-vop (getf slot-opts :set-vop
  50.                   (if setf-vop nil set-trans))))
  51.       (when ref-vop
  52.         (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
  53.                 (:variant ,offset ,lowtag)
  54.               ,@(when ref-trans
  55.               `((:translate ,ref-trans))))))
  56.       (when (or set-vop setf-vop)
  57.         (forms `(define-vop ,(cond ((and rest-p setf-vop)
  58.                     (error "Can't automatically generate ~
  59.                     a setf VOP for :rest-p ~
  60.                     slots: ~S in ~S"
  61.                            name
  62.                            (primitive-object-name obj)))
  63.                        (rest-p `(,set-vop slot-set))
  64.                        ((and set-vop setf-function-p)
  65.                     (error "Setf functions (list ~S) must ~
  66.                     use :setf-vops."
  67.                            set-trans))
  68.                        (set-vop `(,set-vop cell-set))
  69.                        (setf-function-p
  70.                     `(,setf-vop cell-setf-function))
  71.                        (t
  72.                     `(,setf-vop cell-setf)))
  73.               (:variant ,offset ,lowtag)
  74.               ,@(when set-trans
  75.               `((:translate ,set-trans)))))))))
  76.     (when (forms)
  77.       `(progn
  78.      ,@(forms)))))
  79.  
  80.  
  81.  
  82. ;;;; Symbol hacking VOPs:
  83.  
  84. ;;; Do a cell ref with an error check for being unbound.
  85. ;;;
  86. (define-vop (checked-cell-ref)
  87.   (:args (object :scs (descriptor-reg) :target obj-temp))
  88.   (:results (value :scs (descriptor-reg any-reg)))
  89.   (:policy :fast-safe)
  90.   (:vop-var vop)
  91.   (:save-p :compute-only)
  92.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
  93.   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
  94.  
  95. ;;; With Symbol-Value, we check that the value isn't the trap object.  So
  96. ;;; Symbol-Value of NIL is NIL.
  97. ;;;
  98. (define-vop (symbol-value checked-cell-ref)
  99.   (:translate symbol-value)
  100.   (:generator 9
  101.     (move obj-temp object)
  102.     (loadw value obj-temp symbol-value-slot other-pointer-type)
  103.     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
  104.       (inst xor temp value unbound-marker-type)
  105.       (inst beq temp zero-tn err-lab)
  106.       (inst nop))))
  107.  
  108. ;;; With Symbol-Function, we check that the result is a function, so NIL is
  109. ;;; always un-fbound.
  110. ;;;
  111. (define-vop (symbol-function checked-cell-ref)
  112.   (:translate symbol-function)
  113.   (:generator 10
  114.     (move obj-temp object)
  115.     (loadw value obj-temp symbol-function-slot other-pointer-type)
  116.     (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
  117.       (test-simple-type value temp err-lab t function-pointer-type))))
  118.  
  119. #+nil
  120. (define-vop (symbol-setf-function checked-cell-ref)
  121.   (:translate symbol-setf-function)
  122.   (:generator 10
  123.     (move obj-temp object)
  124.     (loadw value obj-temp symbol-setf-function-slot other-pointer-type)
  125.     (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
  126.       (test-simple-type value temp err-lab t function-pointer-type))))
  127.  
  128.  
  129. ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
  130. (define-vop (boundp-frob)
  131.   (:args (object :scs (descriptor-reg)))
  132.   (:conditional)
  133.   (:info target not-p)
  134.   (:policy :fast-safe)
  135.   (:temporary (:scs (descriptor-reg)) value)
  136.   (:temporary (:type random  :scs (non-descriptor-reg)) temp))
  137.  
  138. (define-vop (boundp boundp-frob)
  139.   (:translate boundp)
  140.   (:generator 9
  141.     (loadw value object symbol-value-slot other-pointer-type)
  142.     (inst xor temp value unbound-marker-type)
  143.     (if not-p
  144.     (inst beq temp zero-tn target)
  145.     (inst bne temp zero-tn target))
  146.     (inst nop)))
  147.  
  148.  
  149. ;;; SYMBOL isn't a primitive type, so we can't use it for the arg restriction
  150. ;;; on the symbol case of fboundp.  Instead, we transform to a funny function.
  151.  
  152. (defknown fboundp/symbol (t) boolean (flushable))
  153. ;;;
  154. (deftransform fboundp ((x) (symbol))
  155.   '(fboundp/symbol x))
  156. ;;;
  157. (define-vop (fboundp/symbol boundp-frob)
  158.   (:translate fboundp/symbol)
  159.   (:generator 10
  160.     (loadw value object symbol-function-slot other-pointer-type)
  161.     (test-simple-type value temp target not-p function-pointer-type)))
  162.  
  163. #+nil(progn
  164. (defknown fboundp/setf (t) boolean (flushable))
  165. ;;;
  166. (deftransform fboundp ((x) (cons))
  167.   '(fboundp/setf (cadr x)))
  168. ;;;
  169. (define-vop (fboundp/setf boundp-frob)
  170.   (:translate fboundp/setf)
  171.   (:generator 10
  172.     (loadw value object symbol-setf-function-slot other-pointer-type)
  173.     (test-simple-type value temp target not-p function-pointer-type)))
  174. )
  175.  
  176. (define-vop (fast-symbol-value cell-ref)
  177.   (:variant symbol-value-slot other-pointer-type)
  178.   (:policy :fast)
  179.   (:translate symbol-value))
  180.  
  181. (define-vop (fast-symbol-function cell-ref)
  182.   (:variant symbol-function-slot other-pointer-type)
  183.   (:policy :fast)
  184.   (:translate symbol-function))
  185.  
  186. (define-vop (set-symbol-function)
  187.   (:translate %set-symbol-function)
  188.   (:policy :fast-safe)
  189.   (:args (symbol :scs (descriptor-reg))
  190.      (function :scs (descriptor-reg) :target result))
  191.   (:results (result :scs (descriptor-reg)))
  192.   (:temporary (:scs (non-descriptor-reg)) type)
  193.   (:temporary (:scs (any-reg)) temp)
  194.   (:save-p :compute-only)
  195.   (:vop-var vop)
  196.   (:generator 30
  197.     (let ((closure (gen-label))
  198.       (normal-fn (gen-label)))
  199.       (load-type type function (- function-pointer-type))
  200.       (inst nop)
  201.       (inst xor type closure-header-type)
  202.       (inst beq type zero-tn closure)
  203.       (inst xor type (logxor closure-header-type
  204.                  funcallable-instance-header-type))
  205.       (inst beq type zero-tn closure)
  206.       (inst xor type (logxor funcallable-instance-header-type
  207.                  function-header-type))
  208.       (inst beq type zero-tn normal-fn)
  209.       (inst addu temp function
  210.         (- (ash function-header-code-offset word-shift)
  211.            function-pointer-type))
  212.       (error-call vop kernel:object-not-function-error function)
  213.       (emit-label closure)
  214.       (inst li temp (make-fixup "closure_tramp" :foreign))
  215.       (emit-label normal-fn)
  216.       (storew function symbol symbol-function-slot other-pointer-type)
  217.       (storew temp symbol symbol-raw-function-addr-slot other-pointer-type)
  218.       (move result function))))
  219.  
  220.  
  221. (defknown fmakunbound/symbol (symbol) symbol (unsafe))
  222. ;;;
  223. (deftransform fmakunbound ((symbol) (symbol))
  224.   '(when symbol
  225.      (fmakunbound/symbol symbol)))
  226. ;;;
  227. (define-vop (fmakunbound/symbol)
  228.   (:translate fmakunbound/symbol)
  229.   (:policy :fast-safe)
  230.   (:args (symbol :scs (descriptor-reg) :target result))
  231.   (:results (result :scs (descriptor-reg)))
  232.   (:temporary (:scs (non-descriptor-reg)) temp)
  233.   (:generator 5
  234.     (inst li temp unbound-marker-type)
  235.     (storew temp symbol symbol-function-slot other-pointer-type)
  236.     (inst li temp (make-fixup "undefined_tramp" :foreign))
  237.     (storew temp symbol symbol-raw-function-addr-slot other-pointer-type)
  238.     (move result symbol)))
  239.  
  240.  
  241. ;;; Binding and Unbinding.
  242.  
  243. ;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
  244. ;;; the symbol on the binding stack and stuff the new value into the
  245. ;;; symbol.
  246.  
  247. (define-vop (bind)
  248.   (:args (val :scs (any-reg descriptor-reg))
  249.      (symbol :scs (descriptor-reg)))
  250.   (:temporary (:scs (descriptor-reg)) temp)
  251.   (:generator 5
  252.     (loadw temp symbol symbol-value-slot other-pointer-type)
  253.     (inst addu bsp-tn bsp-tn (* 2 word-bytes))
  254.     (storew temp bsp-tn (- binding-value-slot binding-size))
  255.     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
  256.     (storew val symbol symbol-value-slot other-pointer-type)))
  257.  
  258.  
  259. (define-vop (unbind)
  260.   (:temporary (:scs (descriptor-reg)) symbol value)
  261.   (:generator 0
  262.     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
  263.     (loadw value bsp-tn (- binding-value-slot binding-size))
  264.     (storew value symbol symbol-value-slot other-pointer-type)
  265.     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
  266.     (inst addu bsp-tn bsp-tn (* -2 word-bytes))))
  267.  
  268.  
  269. (define-vop (unbind-to-here)
  270.   (:args (arg :scs (descriptor-reg any-reg) :target where))
  271.   (:temporary (:scs (any-reg) :from (:argument 0)) where)
  272.   (:temporary (:scs (descriptor-reg)) symbol value)
  273.   (:generator 0
  274.     (let ((loop (gen-label))
  275.       (skip (gen-label))
  276.       (done (gen-label)))
  277.       (move where arg)
  278.       (inst beq where bsp-tn done)
  279.  
  280.       (emit-label loop)
  281.       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
  282.       (inst beq symbol zero-tn skip)
  283.       (loadw value bsp-tn (- binding-value-slot binding-size))
  284.       (storew value symbol symbol-value-slot other-pointer-type)
  285.       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
  286.  
  287.       (emit-label skip)
  288.       (inst addu bsp-tn bsp-tn (* -2 word-bytes))
  289.       (inst bne where bsp-tn loop)
  290.       (inst nop)
  291.  
  292.       (emit-label done))))
  293.  
  294.  
  295.  
  296. ;;;; Closure indexing.
  297.  
  298. (define-vop (closure-index-ref word-index-ref)
  299.   (:variant closure-info-offset function-pointer-type)
  300.   (:translate %closure-index-ref))
  301.  
  302. (define-vop (set-funcallable-instance-info word-index-set)
  303.   (:variant funcallable-instance-info-offset function-pointer-type)
  304.   (:translate %set-funcallable-instance-info))
  305.  
  306.  
  307.  
  308. ;;;; Structure hackery:
  309.  
  310. (define-vop (structure-length)
  311.   (:policy :fast-safe)
  312.   (:translate structure-length)
  313.   (:args (struct :scs (descriptor-reg)))
  314.   (:temporary (:scs (non-descriptor-reg)) temp)
  315.   (:results (res :scs (unsigned-reg)))
  316.   (:result-types positive-fixnum)
  317.   (:generator 4
  318.     (loadw temp struct 0 structure-pointer-type)
  319.     (inst srl res temp type-bits)))
  320.  
  321. (define-vop (structure-ref slot-ref)
  322.   (:variant structure-slots-offset structure-pointer-type)
  323.   (:policy :fast-safe)
  324.   (:translate structure-ref)
  325.   (:arg-types structure (:constant index)))
  326.  
  327. (define-vop (structure-set slot-set)
  328.   (:policy :fast-safe)
  329.   (:translate structure-set)
  330.   (:variant structure-slots-offset structure-pointer-type)
  331.   (:arg-types structure (:constant index) *))
  332.  
  333. (define-vop (structure-index-ref word-index-ref)
  334.   (:policy :fast-safe) 
  335.   (:translate structure-ref)
  336.   (:variant structure-slots-offset structure-pointer-type)
  337.   (:arg-types structure positive-fixnum))
  338.  
  339. (define-vop (structure-index-set word-index-set)
  340.   (:policy :fast-safe) 
  341.   (:translate structure-set)
  342.   (:variant structure-slots-offset structure-pointer-type)
  343.   (:arg-types structure positive-fixnum *))
  344.  
  345.  
  346.  
  347. ;;;; Code object frobbing.
  348.  
  349. (define-vop (code-header-ref word-index-ref)
  350.   (:translate code-header-ref)
  351.   (:policy :fast-safe)
  352.   (:variant 0 other-pointer-type))
  353.  
  354. (define-vop (code-header-set word-index-set)
  355.   (:translate code-header-set)
  356.   (:policy :fast-safe)
  357.   (:variant 0 other-pointer-type))
  358.